home *** CD-ROM | disk | FTP | other *** search
/ Mac100% 1998 November / MAC100-1998-11.ISO.7z / MAC100-1998-11.ISO / ｵﾝﾗｲﾝｿﾌﾄ定点観測 / ﾕｰﾃｨﾘﾃｨ / Mops 3.2.sea / Mops 3.2 / Mops ƒ / Args next >
Text File  |  1998-06-07  |  11KB  |  424 lines
  1. ¥ Support for named parms and local variables
  2.  
  3. cr .( loading Args...)
  4.  
  5.    24    constant    MAXPL        ¥ Should be enough!!
  6. false    value        LOCFLG        ¥ true = looking for local var tokens
  7.  
  8.  
  9. create    PARMLIST    maxPL cells  reserve
  10.  
  11.     0    value    SVHASH
  12. false    value    FLOAT?
  13.     0    value    PLentry_addr
  14.  
  15.  
  16. : INITLOCS        ¥ Initializes flags etc.
  17.     0 -> #PL  0 -> #P  0 -> #F
  18.     0 -> FltFlg  false -> locFlg  ;
  19.  
  20.  
  21. : FINDINPARMLIST        ¥ ( addr -- loc# T  OR  -- F )
  22.             ¥ loc# counts from right to left in the local/parm list.
  23.  
  24.     dup 1+ c@   & %  =  -> float?
  25.     hash -> svHash  false
  26.     #PL  0EXIT
  27.     ParmList  #PL 4*  bounds  DO
  28.         svHash  i @ =
  29.         IF  ( found )
  30.             drop  #PL
  31.             i parmlist -  4/
  32.             -  1-  true  LEAVE
  33.         THEN
  34.     4 +LOOP  ;
  35.  
  36.  
  37. : ADDTOPARMLIST        ¥ ( addr -- )  Adds an element to ParmList.
  38.                     ¥  addr points to a counted string.
  39.     findinParmList  ?error 95        ¥ Name not unique
  40.     #PL  maxPL  >  ?error 110        ¥ too many parms/locals
  41.     FltFlg  1 <<   float? if  1 or  1 ++> #F  then  -> FltFlg
  42.     svHash
  43.     #PL  1 ++> #PL  4*  ParmList +  !  ;
  44.  
  45.  
  46. : FIRSTCHR
  47.     here 1+ c@  ;
  48.  
  49.  
  50. :f {
  51.     local? IF            ¥ local? already non-zero - this ought to mean we're
  52.                         ¥  in a local section
  53.         local? 0< ?error 92  -1 -> local?
  54.     THEN
  55.     initLocs
  56.     
  57.     BEGIN                    ¥ Loop to add parms/locals to parmlist
  58.         Mword drop
  59.         firstChr  & -  <>            ¥ look for --
  60.     WHILE
  61.         firstChr dup  & ¥  =  swap  & /  =  or
  62.                 ¥ Note: we allow / as an alternative to ¥ in this context,
  63.                 ¥  since it's an easy mistake to make, and / isn't a
  64.                 ¥  sensible parm name since it already has a meaning.
  65.  
  66.         IF        true -> locFlg
  67.         ELSE    firstChr  & } =  ?error 111
  68.             locFlg nif  1 ++> #P  then
  69.             here  AddToParmList
  70.         THEN
  71.     REPEAT
  72.     local? NIF                ¥ In local sections, we do this at :LOC
  73.         here  -> PLentry_addr
  74.             ¥  If we have temp objects, we'll have to backup the DP and
  75.             ¥  recompile the entry sequence, since there'll be an extra local
  76.             ¥  (the frame pointer)
  77.         PLentry
  78.     THEN
  79.     
  80.     BEGIN                    ¥ Loop gobble chars until }
  81.         Mword drop
  82.         firstChr  & }  =            ¥ look for }
  83.     UNTIL
  84.  
  85. ¥    & }  parse 2drop                ¥ eat characters until }
  86. ¥    rest nip  0< ?error 112  ;f        ¥ Err if no final }
  87. ;f
  88.  
  89.  
  90. ¥ FIND will call Pfind to attempt to find a name first.
  91. ¥ If Pfind finds the name is a local, it returns true and the
  92. ¥ cfa of LocParm, which is a dummy word whose handler compiles
  93. ¥ a local reference.
  94.  
  95. : PFIND        ¥ ( str-addr -- cfa T  |  -- str-addr F )
  96.     state
  97.     NIF        false
  98.     ELSE    dup  FindInParmList
  99.         IF                        ¥ Found
  100.             -> loc#  drop
  101.             float? IF  ['] FlocParm  ELSE  ['] locParm  THEN
  102.             true
  103.         ELSE    false            ¥ Not found
  104.         THEN
  105.     THEN   ;
  106.  
  107.  
  108. : ,EXEC        ¥ ( cfa n -- )
  109.     state
  110.     IF  (compN)  ELSE  exN  THEN  ;
  111.  
  112. ¥ Here are the different types that we can put prefixes on or send
  113. ¥ messages to:
  114.  
  115. TYPE{    notfnd  locTyp  flocTyp
  116.         tmpObjTyp  objTyp  ivarTyp  classTyp  superTyp
  117.         valTyp  fvalTyp  vecTyp  dynVecTyp  objptrTyp
  118.         regTyp  lbTyp  lbSelfTyp  bktTyp  wordTyp  }
  119.  
  120. ¥ notFnd    - not previously defined
  121. ¥ locTyp    - a local or named parm
  122. ¥ tmpObjTyp    - a temporary (local) object
  123. ¥ objTyp    - an object
  124. ¥ ivarTyp    - an ivar
  125. ¥ classTyp    - a class
  126. ¥ superTyp    - a named superclass specified by  msg: super> someClass
  127. ¥ valTyp    - a value
  128. ¥ FvalTyp    - a floating point value
  129. ¥ vecTyp    - a vector
  130. ¥ dynVecTyp    - a dynamic vector
  131. ¥ regTyp    - a 680x0 register
  132. ¥ lbTyp        - ** or [] meaning late bind
  133. ¥ lbSelfTyp    - [self] meaning late bind to self
  134. ¥ BktTyp    - [ - Neon-compatible late bind
  135. ¥ wordTyp    - a word
  136.  
  137. ¥ PRFTOKEN returns the type of a token for a prefix op.
  138.  
  139. ¥ First we need to make some handler codes available above the Nucleus.
  140. ¥ In the PowerPC dic we're using  $BCxx and  $BDxx for non-colon handler
  141. ¥ codes to  make disassembly easier, and as a sanity check for EXECUTE.
  142. ¥ We sort out the difference here.  xx is positive, and half our 68k
  143. ¥ handler code (which is always even).
  144.  
  145. : HDLR        ¥ ( cfa -- ha )
  146.     2- w@x
  147.     dup $ FE00 and $ BC00 =
  148.     IF    $ FF and
  149.         dup $ 3D = IF drop 5 THEN    ¥ treat vects and sVects the same
  150.         2* negate
  151.     THEN
  152. ;
  153.  
  154.  
  155. ' key    hdlr    constant    VECTCODE
  156. ' base    hdlr    constant    VALCODE
  157. ' ^base    hdlr    constant    REGCODE
  158. ' hdlr    hdlr    constant    WORDCODE
  159.  
  160.     objPtr XX          ' xx  hdlr        forget xx
  161.                 constant    OBJPTRCODE
  162.     dynamicVect XX    ' xx  hdlr        forget xx
  163.                 constant    DYNVECTCODE
  164.  
  165. : PRFTOKEN    ¥ ( -- cfa type )
  166.     '  dup  ['] locParm  =  IF  locTyp    EXIT  THEN
  167.        dup  ['] FlocParm =  IF  FlocTyp    EXIT  THEN
  168.     dup  hdlr
  169.     CASE
  170.         valCode        OF    valTyp        ENDOF
  171.         FvalCode    OF    FvalTyp        ENDOF
  172.         vectCode    OF    vecTyp        ENDOF
  173.         dynVectCode    OF    dynVecTyp    ENDOF
  174.         regCode        OF    regTyp        ENDOF
  175.         objPtrCode    OF    objPtrTyp    ENDOF
  176.         114 die
  177.     ENDCASE  ;
  178.  
  179.  
  180. forward    ToObjPtr        ¥ Stores to an objPtr.  Defined in file Class.
  181.  
  182. : ->
  183.     PrfToken                ¥ All types are legal
  184.     objPtrTyp =  IF  toObjPtr  EXIT  THEN
  185.     $ 60  ( opcode for Store )  ,exec
  186. ;        immediate            ¥ NOTE: opcode for store hard coded here!!!
  187.  
  188.  
  189. : CvrtFcode    ¥ ( code -- code' )
  190.     CASE
  191.         $ 21  OF  $ 41  ENDOF        ¥ +
  192.         $ 22  OF  $ 48  ENDOF        ¥ -
  193.         $ 28  OF  $ 55  ENDOF        ¥ Neg
  194.         ?error 114
  195.     ENDCASE  ;
  196.  
  197. : (+->)        ¥ ( code -- cfa code' )
  198.     PrfToken ( code cfa type )  rot swap ( cfa code type )
  199.     
  200.     CASE
  201.         locTyp        OF                ENDOF
  202.         FlocTyp        OF  cvrtFcode    ENDOF
  203.         valTyp        OF                ENDOF
  204.         FvalTyp        OF  cvrtFcode    ENDOF
  205.         regTyp        OF                ENDOF
  206.         ?error 114
  207.     ENDCASE  ;
  208.  
  209. : (FOP)
  210.     PrfToken  rot swap
  211.     CASE
  212.         locTyp        OF  ENDOF
  213.         FlocTyp        OF  ENDOF
  214.         FvalTyp        OF  ENDOF
  215.         ?error 114
  216.     ENDCASE  ;
  217.  
  218. ¥ Note: the following opcodes have to agree with the definitions in
  219. ¥ OD.asm.  I could have defined them as constants but this would have
  220. ¥ used up dictionary space for no great benefit.
  221.  
  222. : ++>    $ 21  (+->)  ,exec  ;        immediate
  223. : +>    postpone  ++>       ;        immediate        ¥ A synonym.
  224. : -->    $ 22  (+->)  ,exec  ;        immediate
  225. : AND>    $ 23  (+->)  ,exec  ;        immediate
  226. : OR>    $ 24  (+->)  ,exec  ;        immediate
  227. : XOR>    $ 25  (+->)  ,exec  ;        immediate
  228. : NEG>    $ 28  (+->)  ,exec  ;        immediate
  229. : NOT>    $ 29  (+->)  ,exec  ;        immediate
  230. : *>    $ 42  (fop)  ,exec  ;        immediate
  231. : />    $ 49  (fop)  ,exec  ;        immediate
  232. : ABS>    $ 54  (fop)  ,exec  ;        immediate
  233.  
  234.  
  235. ' Pfind  -> Ufind
  236.  
  237.  
  238. ¥         =========== Local sections ===========
  239.  
  240. forward        INITTEMPS
  241.  
  242. : ?LOC    local? 0=  ?error 91  ;            ¥ "We're not in a local section"
  243.  
  244. : LOCAL
  245.     local?  ?error 93  1 -> local?        ¥ We change it to the normal -1
  246.                                         ¥ as soon as "{" is read.
  247.     forward  ;
  248.  
  249.  
  250. : :LOC        immediate
  251.     local? 1 = IF  msg# 96  THEN        ¥ warning  - no locals defined
  252.     ?loc  304
  253.     here  '  (patch)  (:)                ¥ Like :F
  254.     #PL  IF  PLentry  THEN
  255.     frameSize IF  initTemps  THEN
  256.     false -> local?                ¥ We do this here so any EXITs
  257. ;                                ¥  tidy everything up properly
  258.  
  259.  
  260. : ;LOC        immediate
  261.     (;)  304 ?defn  ;        ¥ As local? is now false, everything else
  262.                             ¥ gets tidied up by (;)
  263.  
  264.  
  265. ¥            ============================================
  266.  
  267. false    value    compinline?
  268.  
  269. : EVALUATE  { addr len ¥ x1 x2 x3 x4 -- ?? }
  270.  
  271.     save-input  drop            ¥ Must be 4
  272.     -> x4 -> x3 -> x2 -> x1        ¥ Move input-stream specs to locals
  273.  
  274.     addr -> src-start  len -> src-len  0 >in !  -1 -> source-id
  275.     echo?
  276.     IF    emb_obj_offs  ." ***evaluating***  "  addr len type cr
  277.         -> emb_obj_offs
  278.     THEN
  279.     interpret
  280.     x1 x2 x3 x4  4  restore-input  ?error 25  ;
  281.  
  282. ¥ We can EVALUATE strings which might have embedded returns, and we can't
  283. ¥ just convert returns to blanks since we want the comment operator ¥
  284. ¥ to only skip to the end of the line, not the end of the string.  We handle
  285. ¥ this by defining an immediate "word" which just consists of a return, which
  286. ¥ does nothing.  We initially define it as X then patch it.  Our dic
  287. ¥ threading scheme doesn't clobber this since we just hash on the length,
  288. ¥ which remains 1.
  289.  
  290. : X        ;  immediate
  291.  
  292. 13 ( cr )   ' x  >name 1+  c!
  293.  
  294.  
  295. : (COMPINL)        ¥ ( cfa -- )
  296.  
  297.     true -> compinline?
  298.     2+ count  evaluate
  299.     false -> compinline?  ;
  300.  
  301. ' (compinl) -> compinline
  302.  
  303. (*
  304. : INLINE{        immediate
  305.     method? IF  -4 allot  THEN        ¥ Wipe out method entry sequence
  306.                                     ¥ %%% watch this on PPC!
  307.     inlMk w,  & }  ,str
  308.     align-dp
  309.     method? IF  Mentry  THEN        ¥ Recompile method entry sequence
  310.     postpone ]  ;
  311. *)
  312.  
  313.  
  314. : INLINE{  { ¥ addr len sv>in  --< inline source text> }
  315.     method? IF  -4 allot  THEN        ¥ Wipe out method entry sequence
  316.                                     ¥ %%% watch this on PPC!
  317.     inlMk w,
  318.     DP  >r                            ¥ save location of start of string
  319.                                     ¥  for EVALUATE below
  320.     & }  ,str
  321.     align-dp
  322.     method? IF  Mentry  THEN        ¥ recompile method entry sequence
  323.     r> count evaluate                ¥ compile out-of-line code
  324.  
  325. ¥ Previous Mops versions required the out-of-line code to be
  326. ¥  explicitly put in.  We don't need this any more, but we
  327. ¥  still need to skip it if it's there.
  328.  
  329.     BEGIN
  330.         >in @  -> sv>in
  331.         Mword count  -> len -> addr
  332.         addr len " ;" s=
  333.         addr len " ;M" s= or
  334.     UNTIL
  335.     sv>in  >in !
  336. ;        immediate
  337.  
  338.  
  339. : [IF]  { flag ¥ addr len level done? -- }
  340.     flag  ?EXIT
  341.     false -> done?  1 -> level
  342.     BEGIN
  343.         Mword count  -> len  -> addr
  344.                 addr len  " [THEN]" s=  IF  1 --> level
  345.         ELSE    addr len  " [ELSE]" s=  IF  level 1 =
  346.                                             IF  true -> done?  THEN
  347.         ELSE    addr len  " [IF]"   s=  IF  1 ++> level
  348.         THEN THEN THEN
  349.  
  350.         level  NIF  true -> done?  THEN
  351.         done?
  352.     UNTIL
  353. ;                immediate
  354.         
  355. : [ELSE]  { ¥ addr len level done? -- }
  356.     false -> done?  1 -> level
  357.     BEGIN
  358.         Mword count  -> len  -> addr
  359.                 addr len    " [THEN]" s=  IF  1 --> level
  360.         ELSE    addr len    " [IF]"   s=  IF  1 ++> level
  361.         THEN THEN
  362.  
  363.         level  NIF  true -> done?  THEN
  364.         done?
  365.     UNTIL
  366. ;                immediate
  367.  
  368. : [THEN]  ;        immediate
  369.  
  370.  
  371. ¥                    =============================
  372. ¥                            ASSERTIONS
  373. ¥                    =============================
  374.  
  375. (*    Assertions allow you, during development, to ensure that
  376.     things are the way they're supposed to be at key places.
  377.     
  378.     Usage:
  379.     ASSERT{ <something that evaluates to a flag> }
  380.     
  381.     If ASSERTIONS? is true, this will give error 216 ("assertion failed")
  382.     if the evaluated flag is false.  If ASSERTIONS? is false, nothing
  383.     will happen - the code between ASSERT{ and } isn't executed.
  384.  
  385.     ASSERTIONS? can be defined and redefined however and whenever you
  386.     like, as long as it returns a flag - ASSERT{ tests it via EVALUATE,
  387.     so the latest definition will be the one that gets looked at.
  388.     If you have ASSERTIONS? defined as a constant with value false, no 
  389.     code will even be compiled for the assertion test - you can use this
  390.     for code that you know works.
  391. *)
  392.     
  393. false    constant    assertions?        ¥ redefine however and whenever necessary
  394.  
  395. : }ASSERT
  396.     134 ?pairs
  397.     ['] } >body !
  398.  
  399.     " NIF 216 die THEN THEN"  evaluate        ¥ assertion failed!
  400. ;        immediate
  401.  
  402.  
  403. : ASSERT{
  404.     ?comp
  405.     " assertions? if" evaluate
  406.     
  407.     ['] } >body @                ¥ save old action for "}"
  408.     ['] }assert  -> }            ¥ "}" will now be same as }assert
  409.     134
  410. ;        immediate
  411.  
  412.  
  413.  
  414. ¥                    ==============================
  415. ¥                            SUNDRY INLINES
  416. ¥                    ==============================
  417.  
  418. : UNDER+  ( n1 n2 n3 -- n1+n3 n2 )
  419.     inline{ rot + swap}  ;
  420.  
  421.  
  422.  
  423. load class
  424.